home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / FORTHLIB.4TH < prev    next >
Encoding:
Text File  |  1994-10-30  |  7.3 KB  |  159 lines
  1. \ FORTH COMPILER  FORTH-83 LIBRARY               09:29 12/30/91
  2.  
  3. \ COPYRIGHT 1985 (C) BY THOMAS ALMY.  ALL RIGHTS RESERVED
  4.  
  5. \ Permission is granted to registered users of ForthCMP to
  6. \ sell or distribute computer programs incorporating the compiled
  7. \ contents of this file.
  8.  
  9. \ SKIP AND SCAN ARE FROM LAXEN & PERRY FORTH 83.
  10.  
  11. CR .( LOADING FORTHLIB ) CR HEX  FORTH
  12. U: #IN  PAD DUP 50 ACCEPT NUM? 0= IF 0 ELSE DROP THEN ;
  13. U: NUM?  OVER C@ [CHAR] - = IF 1 /STRING TRUE ELSE FALSE THEN
  14.    >R  0. 2SWAP >NUMBER  IF  C@ BL <> IF R> DROP 2DROP 0 EXIT
  15.    THEN  ELSE DROP THEN  R> IF DNEGATE THEN -1 ;
  16. U: CONVERT CHAR+ 65535 >NUMBER DROP ;
  17. U: >NUMBER BEGIN DUP 0= IF EXIT THEN  >R DUP >R C@
  18.  [CHAR] 0 - DUP 0< IF 0 ELSE DUP 9 > IF 7 - THEN DUP BASE @ <
  19.  THEN WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+
  20.  R> R> 1 /STRING REPEAT DROP R> R> ;
  21. ?DEFINE PARSE ?DEFINE PARSE-WORD ?DEFINE WORD ?DEFINE REFILL ?DEFINE >BUFFER OR OR OR OR [IF]
  22. FIND >IN [IF] DROP [ELSE] VARIABLE >IN [THEN] [THEN]
  23. U: WORD  PARSE-WORD  1F MIN  DUP HERE C!
  24.    DUP HERE + 1+ BL C<-  HERE 1+ SWAP CMOVE   HERE ;
  25. U: PARSE-WORD >R  SOURCE >IN @ /STRING R@  OVER  >R  SKIP
  26.    R> SWAP - >IN +!  DROP R>  PARSE ;
  27. UNDEF UNUSED CODE UNUSED  SI POP
  28. SEPSSEG? 0= [IF] SP AX MOV [ELSE]
  29. SEPDSEG? [IF] dssize 10 * # AX MOV  [ELSE]
  30. FIND PSIZE [IF] DROP PSIZE [ELSE] FFFE [THEN] # AX MOV
  31. [THEN] [THEN] DP [] AX SUB  AX PUSH  SI JMPI  END-CODE [THEN]
  32. U: PARSE >R  SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER -
  33.    DUP R> IF 1+ THEN >IN +! ;
  34. UNDEF SKIP   ASM L: done  CX PUSH  BX JMPI
  35. CODE SKIP BX POP AX POP  CX POP  done LOOP ~ JMPC
  36.   DI POP  DX DS <SEG  DX ES >SEG  REPZ BYTE SCAS =0 ~ IF, CX INC
  37.   DI DEC THEN,  DI PUSH CX PUSH BX JMPI END-CODE [THEN]
  38. UNDEF SCAN  FIND done 0= [IF] ASM L: done CX PUSH BX JMPI
  39.   [ELSE] DROP [THEN]
  40. CODE SCAN BX POP AX POP CX POP done LOOP ~ JMPC  DI POP
  41.   DX DS <SEG DX ES >SEG  REPNZ BYTE SCAS =0 IF, CX INC DI DEC
  42.   THEN, DI PUSH CX PUSH BX JMPI END-CODE  [THEN]
  43. ?DEFINE REFILL ?DEFINE SOURCE ?DEFINE >BUFFER OR OR [IF]
  44. FIND #TIB [IF] DROP [ELSE] VARIABLE #TIB [THEN]  FIND TIB
  45. [IF] DROP [ELSE] DSEG CREATE TIB 80 ALLOT [THEN] [THEN]
  46. U: >BUFFER 80 MIN DUP #TIB ! TIB SWAP CMOVE >IN OFF ;
  47. U: REFILL TIB 80 ACCEPT #TIB ! >IN OFF TRUE ;
  48. PRIMITIVE U: SOURCE  TIB  #TIB @ ;
  49. U: ACCEPT >R  0  BEGIN   KEY   CASE
  50.  [CTRL] M OF  NIP R> DROP   EXIT ENDOF
  51.  [CTRL] H OF DUP IF 8 EMIT BL EMIT 8 EMIT 1- THEN  ENDOF
  52.  [CTRL] [ OF 0 ?DO 8 EMIT BL EMIT 8 EMIT LOOP 0 ENDOF
  53.  OVER R@ <> IF DUP >R EMIT 2DUP + R> SWAP C! 1+ 0 THEN ENDCASE AGAIN ;
  54. U: DMIN 2OVER 2OVER D<  0= IF 2SWAP THEN 2DROP ;
  55. U: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
  56. PRIMITIVE  U: D< ROT SWAP 2DUP <> IF < -ROT 2DROP ELSE 2DROP U< THEN ;
  57. U: DU< ROT SWAP 2DUP <> IF 2SWAP THEN 2DROP U< ;
  58. UNDEF 2SWAP  CODE 2SWAP SI POP AX POP BX POP CX POP DX POP
  59.   BX PUSH AX PUSH DX PUSH CX PUSH SI JMPI END-CODE [THEN]
  60. U: 2ROT  5 ROLL 5 ROLL ;
  61. PRIMITIVE U: D=  ROT = >R = R> AND ;
  62. U: D.  0 D.R SPACE ;
  63. U: D.R >R  TUCK DABS <# #S ROT SIGN #> R> OVER - SPACES TYPE ;
  64. UNDEF D2/ CODE D2/ AX 1 SAR BX 1 RCR RET END-CODE [THEN]
  65. UNDEF D2* CODE D2* BX BX ADD AX AX ADC RET END-CODE [THEN]
  66. U: DABS DUP 0< IF DNEGATE THEN ;
  67. U: (.") CS: COUNT 2DUP + -ROT CS:TYPE ;
  68. PRIMITIVE U: HEX 10 BASE ! ; 
  69. PRIMITIVE U: DECIMAL 0A BASE ! ;
  70. U: U. 0 <# #S #> TYPE SPACE ;
  71. U: U.R >R 0 <# #S #> R> OVER - SPACES TYPE ;
  72. U: . DUP ABS 0 <# #S ROT SIGN #> TYPE SPACE ;
  73. U: .R >R DUP ABS 0 <# #S ROT SIGN #> R> OVER - SPACES TYPE ;
  74. U: SPACES DUP 0> IF 0 DO SPACE LOOP EXIT THEN DROP ;
  75. FIND EMIT ?DUP [IF] ?DEFINE CS:TYPE [IF]
  76. SEPDSEG? [IF]  : CS:TYPE 0 ?DO  CS: COUNT EMIT LOOP DROP ;
  77. [ELSE] CODE CS:TYPE END-CODE REQUIRES TYPE [THEN] [THEN]
  78. U: TYPE 0 ?DO COUNT EMIT LOOP DROP ; [THEN]
  79. U: SPACE 20 EMIT ;
  80. U: #S BEGIN # 2DUP OR 0= UNTIL ;
  81. U: #  BASE @ MU/MOD ROT 9 OVER < IF 7 + THEN 30 + HOLD ;
  82. U: MU/MOD >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
  83. U: SIGN 0< IF 2D HOLD THEN ;
  84. UNDEF HOLD FIND HLD [IF] DROP [ELSE] VARIABLE HLD [THEN]
  85.   : HOLD -1 HLD +! HLD @ C! ; [THEN]
  86. U: #> 2DROP HLD @ PAD OVER - ;
  87. U: <# PAD HLD ! ;
  88. UNDEF -TRAILING  CODE -TRAILING AX CX MOV BX AX MOV LOOP IF,
  89.   CX BX ADD BX DEC BEGIN, 20 # [BX] BYTE CMP  =0 IF, BX DEC
  90.   SWAP  LOOP ~ UNTIL,  THEN, AX BX MOV THEN, CX AX MOV RET
  91.   END-CODE [THEN]
  92. PRIMITIVE U:  /STRING TUCK - -ROT + SWAP ;
  93. UNDEF DEPTH CODE DEPTH  S0 [] AX MOV  SP AX SUB  AX 1 SAR
  94.   RET END-CODE   [THEN]
  95. ALIGNED? [IF] PRIMITIVE U: ALIGN  DP @ 1+ -2 AND DP ! ;
  96. [ELSE] PRIMITIVE U: ALIGN ; [THEN]
  97. U: ALLOT  DP +! ;
  98. U: HERE  DP @ ;
  99. U: PAD   DP @ 64 + ;
  100. U: C, DP @ C! 1 DP +! ;
  101. U: ,  DP @ !  2 DP +! ;
  102. U: BLANK BL FILL ;
  103. U: ERASE 0 FILL ;
  104. UNDEF WITHIN CODE WITHIN   SI POP AX POP BX POP BX AX SUB
  105.    DX POP  BX DX SUB  AX DX CMP 0 # AX MOV <U IF, AX DEC THEN,
  106.    AX PUSH SI JMPI  [THEN]
  107. U: MOVE  >R  2DUP U< IF R> CMOVE>  ELSE  R> CMOVE  THEN ;
  108. UNDEF CMOVE> CODE CMOVE>  BX POP  CX POP DI POP SI POP
  109.   CX AX MOV AX DEC  AX SI ADD AX DI ADD  STD  AX DS <SEG
  110.   AX ES >SEG REPZ BYTE MOVS CLD BX JMPI END-CODE [THEN]
  111. UNDEF CMOVE CODE CMOVE  BX POP  CX POP DI POP SI POP
  112.     AX DS <SEG AX ES >SEG REPZ BYTE MOVS BX JMPI
  113.     END-CODE [THEN]
  114. UNDEF FILL CODE FILL  BX POP AX POP CX POP DI POP
  115.   DX DS <SEG DX ES >SEG REPZ BYTE STOS BX JMPI END-CODE [THEN]
  116. UNDEF ROLL  CODE ROLL  BX POP  DI POP  AX SS <SEG AX ES >SEG
  117.   DI CX MOV CX INC  DI 1 SHL SP DI ADD DI SI MOV SI DEC SI DEC
  118.   SS: [DI] PUSH STD CLI REPZ MOVS STI CLD
  119.   SP INC SP INC BX JMPI  END-CODE [THEN]
  120. UNDEF DNEGATE  CODE DNEGATE  AX NOT BX NOT 1 # BX ADD
  121.    0 # AX ADC RET END-CODE [THEN]
  122. U: KEY  0 8 BDOS ;  
  123. U: KEY? 0 0B BDOS 0<> ;
  124. U: CR   0D EMIT 0A EMIT ;
  125. ?DEFINE EMIT ?DEFINE TYPE ?DEFINE CS:TYPE ?DEFINE CONSOLE
  126. ?DEFINE PRINTER ?DEFINE MESSAGES OR OR OR OR OR [IF]
  127. FIND of [IF] DROP [ELSE] VARIABLE of DSEG 1 of ! [THEN]  [THEN]
  128. UNDEF EMIT HERE 1 ALLOT
  129. CODE EMIT AL OVER [] MOV 40 # AH MOV 1 # CX MOV DUP # DX MOV
  130.    of [] BX MOV 21 INT RET END-CODE DROP [THEN]
  131. UNDEF CS:TYPE  CODE CS:TYPE SEPDSEG? [IF] AX CX MOV BX DX MOV
  132.  of [] BX MOV  DS PUSHSEG  AX CS <SEG AX DS >SEG 40 # AH MOV
  133.   21 INT DS POPSEG RET [ELSE] REQUIRES TYPE [THEN] END-CODE [THEN]
  134. UNDEF TYPE CODE TYPE AX CX MOV BX DX MOV of [] BX MOV
  135.   40 # AH MOV 21 INT RET END-CODE [THEN]
  136. UNDEF CONSOLE CODE CONSOLE 1 # of [] MOV RET END-CODE [THEN]
  137. UNDEF PRINTER CODE PRINTER 4 # of [] MOV RET END-CODE [THEN]
  138. UNDEF MESSAGES CODE MESSAGES 2 # of [] MOV RET END-CODE [THEN]
  139. UNDEF BDOS  CODE BDOS AL AH MOV BX DX MOV 21 INT AH AH XOR RET END-CODE [THEN]
  140. UNDEF BYE  CODE BYE ' bye JMP END-CODE [THEN]
  141. UNDEF RETURN CODE RETURN AX POP AX POP 4C # AH MOV 21 INT END-CODE [THEN]
  142. UNDEF CMOVEL CODE CMOVEL BX POP CX POP DI POP ES POPSEG SI POP
  143.     DX DS <SEG DS POPSEG   REPZ BYTE MOVS
  144.     DX DS >SEG BX JMPI END-CODE   [THEN]
  145. PRIMITIVE U: 2OVER 3 PICK 3 PICK ;
  146. PRIMITIVE U: */MOD >R M* R> SM/REM ;
  147. UNDEF M*/ CODE M*/   SI POP  DI POP BX POP CX POP AX POP
  148. BX BX OR <0 IF, CX NOT AX NOT AX INC 0 # CX ADC BX NOT BX INC
  149. THEN, BX MUL AX CX XCHG DX PUSH BX IMUL
  150. BX POP BX AX ADD  0 # DX ADC  DX PUSH
  151. <0 IF, DX NOT AX NOT CX NOT CX INC 0 # AX ADC 0 # DX ADC THEN,
  152. DI DIV  DX BX MOV  AX BX MOV  CX AX MOV  DI DIV
  153. DX POP  DX DX OR <0 IF, AX NOT BX NOT AX INC 0 # BX ADC THEN,
  154. AX PUSH  BX PUSH   SI JMPI  END-CODE  [THEN]
  155. UNDEF (do)  CODE (do) 8000 # DX MOV  AX DX SUB  CX DX ADD
  156.     BP DEC BP DEC DX [BP] MOV  RET [THEN]
  157. UNDEF (?do) CODE (?do) 8000 # DX MOV AX DX SUB  CX DX ADD
  158.     BP DEC BP DEC DX [BP] MOV  AX CX CMP  RET [THEN]
  159.